home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trans4.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  8.0 KB  |  267 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;       1001 TRANSLATE properties for everyone.                        ;;;
  10. ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11. ;;;       Maintained by GJC                                              ;;;
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (in-package "MAXIMA")
  15.  
  16. (macsyma-module trans4)
  17.  
  18. (TRANSL-MODULE TRANS4)
  19.  
  20. ;;; These are translation properties for various operators.
  21.  
  22. (DEF%TR MNCTIMES (FORM)
  23.     (SETQ FORM (TR-ARGS (CDR FORM)))
  24.     (COND ((= (LENGTH FORM) 2)
  25.            `($ANY NCMUL2 . ,FORM))
  26.           (T
  27.            `($ANY NCMULN (LIST . ,FORM) NIL))))
  28.  
  29. (DEF%TR MNCEXPT (FORM)
  30.     `($ANY . (NCPOWER ,@(TR-ARGS (CDR FORM)))))
  31.  
  32. ; maybe this ?
  33. (COMMENT 
  34. (DEFUN STRICT-UNION-MODE-OF-TFORMS (L)
  35.        (DO ((M (CAAR L))
  36.         (L (CDR L)(CDR L)))
  37.        ((NULL L) M)
  38.        (AND (NOT (EQ M (CAAR L))) (RETURN '$ANY))))
  39.  
  40. (DEFMACRO DEF%MODAL1%TR (NAME ARGS &REST CASES)
  41.       `(DEF%TR ,NAME (*TR-FORM-ARGUMENT*)
  42.            (COND ((= (LENGTH *TR-FORM-ARGUMENT*) ,(f1+ (LENGTH ARGS)))
  43.               (LET* ((*TR-ARGS* (MAPCAR #'TRANSLATE
  44.                             (CDR *TR-FORM-ARGUMENT*)))
  45.                  (*MODE* (STRICT-UNION-MODE-OF-TFORMS  *TR-ARGS*)))
  46.                 (SETQ *TR-ARGS* (MAPCAR #'CDR *TR-ARGS*)))))))
  47.                 
  48.  
  49. (DEF-MODAL-TR $BETA (X Y)
  50.           ($FLOAT (//$ (*$ ($GAMMA X) ($GAMMA Y))
  51.                 ($GAMMA (+$ X Y))))
  52.           ($NUMBER (QUOTIENT (TIMES ($GAMMA X) ($GAMMA Y))
  53.                   ($GAMMA (PLUS X Y))))
  54.           ($ANY (SIMPLIFY (LIST '($BETA) X Y))))
  55.  
  56. (DEF-MODAL-TR $GAMMA (X)
  57.           ($FLOAT ($GAMMA X))
  58.           ($ANY (SIMPLIFY ($GAMMA X)))))
  59.  
  60. ;;; end of commented out code.
  61.  
  62. (DEF%TR $REMAINDER (FORM)
  63.     (let ((n (TR-NARGS-CHECK FORM '(2 . NIL)))
  64.           (tr-args (mapcar 'translate (cdr form))))
  65.          (cond ((and (= n 2)
  66.              (eq (caar tr-args) '$fixnum)
  67.              (EQ (CAR (CADR TR-ARGS)) '$FIXNUM))
  68.             `($FIXNUM . (REMAINDER ,(CDR (CAR TR-ARGS))
  69.                        ,(CDR (CADR TR-ARGS)))))
  70.            (T
  71.             (CALL-AND-SIMP '$ANY '$REMAINDER (MAPCAR 'CDR TR-ARGS))))))
  72.  
  73. (DEF%TR $BETA (FORM)
  74.     `($ANY . (SIMPLIFY (LIST '($BETA) ,@(TR-ARGS (CDR FORM))))))
  75.  
  76. (DEF%TR MFACTORIAL (FORM)
  77.     (SETQ FORM (TRANSLATE (CADR FORM)))
  78.     (COND ((EQ (CAR FORM) '$FIXNUM)
  79.            `($NUMBER . (FACTORIAL ,(CDR FORM))))
  80.           (T
  81.            `($ANY . (SIMPLIFY  `((MFACTORIAL) ,,(CDR FORM)))))))
  82.  
  83. (DEF%TR %SUM (FORM)
  84.     ;; this is WRONG. ---FIX--THIS--YOU--LOSER----*****
  85.     `($ANY . (MEVAL ',FORM)))
  86.  
  87. (DEF%TR %PRODUCT (FORM)
  88.     `($ANY . (MEVAL ',FORM)))
  89.  
  90. ;(DEF%TR %BINOMIAL (FORM)
  91. ;    (TR-NARGS-CHECK FORM '(2 .2))
  92. ;    `($ANY . ($BINOMIAL ,@(TR-ARGS (CDR FORM)))))
  93.  
  94.  
  95.  
  96. ;; From MATCOM.
  97. ;; Temp autoloads needed for pdp-10. There is a better way
  98. ;; to distribute this info, too bad I never implemented it.
  99.  
  100. (MAPC #'(LAMBDA (X)
  101.          (LET ((OLD-PROP (GET (CDR X) 'AUTOLOAD)))
  102.            (IF (NOT (NULL OLD-PROP))
  103.            (PUTPROP (CAR X) OLD-PROP 'AUTOLOAD))))
  104.       '((PROC-$MATCHDECLARE . $MATCHDECLARE)
  105.     (PROC-$DEFMATCH .     $DEFMATCH)
  106.     (PROC-$DEFRULE . $DEFRULE)
  107.     (PROC-$TELLSIMPAFTER . $TELLSIMPAFTER)
  108.     (PROC-$TELLSIMP     . $TELLSIMP    )))
  109.  
  110. (DEFUN YUK-SU-META-PROP (F FORM)
  111.   (LET ((META-PROP-P T)
  112.     (META-PROP-L NIL))
  113.     (FUNCALL F (CDR FORM))
  114.     `($ANY . (PROGN 'compile ,@(MAPCAR #'PATCH-UP-MEVAL-IN-FSET (NREVERSE META-PROP-L))))))
  115.  
  116. (DEF%TR $MATCHDECLARE (FORM)
  117.   (DO ((L (CDR FORM) (CDDR L))
  118.        (VARS ()))
  119.       ((NULL L)
  120.        `($ANY. (PROGN 'COMPILE
  121.               ,@(MAPCAR #'(LAMBDA (VAR)
  122.                     (DTRANSLATE `(($DEFINE_VARIABLE)
  123.                           ,VAR
  124.                           ((MQUOTE) ,VAR)
  125.                           $ANY)))
  126.                 VARS)
  127.               ,(DTRANSLATE `((SUB_$MATCHDECLARE) ,@(CDR FORM))))))
  128.     (COND ((ATOM (CAR L))
  129.        (PUSH (CAR L) VARS))
  130.       ((EQ (CAAAR L) 'MLIST)
  131.        (SETQ VARS (APPEND (CDAR L) VARS))))))
  132.  
  133. (DEF%TR SUB_$MATCHDECLARE (FORM)
  134.   (YUK-SU-META-PROP 'PROC-$MATCHDECLARE `(($MATCHDECLARE) ,@(CDR FORM))))
  135.  
  136. (DEF%TR $DEFMATCH (FORM)
  137.   (YUK-SU-META-PROP 'PROC-$DEFMATCH FORM))
  138.  
  139. (DEF%TR $TELLSIMP (FORM)
  140.   (YUK-SU-META-PROP 'PROC-$TELLSIMP FORM))
  141.  
  142. (DEF%TR $TELLSIMPAFTER (FORM)
  143.   (YUK-SU-META-PROP 'PROC-$TELLSIMPAFTER FORM))
  144.  
  145. (DEF%TR $DEFRULE (FORM)
  146.   (YUK-SU-META-PROP 'PROC-$DEFRULE FORM))
  147.  
  148. (DEFUN PATCH-UP-MEVAL-IN-FSET (FORM)
  149.   (COND ((NOT (EQ (CAR FORM) 'FSET))
  150.      FORM)
  151.     
  152.     (T
  153.      (TR-FORMAT "~%Translating rule or match ~:M" (CADR (CADR FORM)))
  154.      (LET ((L (LISP->LISP-TR-LAMBDA (CADR (CADDR FORM)))))
  155.        (IF (NULL L)
  156.            FORM
  157.            `(DEFUN ,(CADR (CADR FORM)) ,@(CDR L)))))))
  158.  
  159. (DEFVAR LISP->LISP-TR-LAMBDA T)
  160.  
  161. (DEFUN LISP->LISP-TR-LAMBDA (L)
  162.   ;; basically, a lisp->lisp translation, setting up
  163.   ;; the proper lambda contexts for the special forms,
  164.   ;; and calling TRANSLATE on the "lusers" generated by
  165.   ;; Fateman braindamage, (MEVAL '$A), (MEVAL '(($F) $X)).
  166.   (IF LISP->LISP-TR-LAMBDA
  167.       (CATCH 'LISP->LISP-TR-LAMBDA
  168.     (TR-LISP->LISP L))
  169.       ()))
  170.  
  171. (DEFUN TR-LISP->LISP (EXP)
  172.   (IF (ATOM EXP)
  173.       (CDR (TRANSLATE-ATOM EXP))
  174.       (LET ((OP (CAR EXP)))
  175.     (IF (SYMBOLP OP)
  176.         (FUNCALL (OR (GET OP 'TR-LISP->LISP) #'TR-LISP->LISP-DEFAULT)
  177.              EXP)
  178.         (PROGN (TR-TELL "Punting: non-symbolic operator")
  179.            (THROW 'LISP->LISP-TR-LAMBDA ()))))))
  180.  
  181. (DEFUN TR-LISP->LISP-DEFAULT (EXP)
  182.   (COND ((MACSYMA-SPECIAL-OP-P (CAR EXP))
  183.      (TR-TELL "Punting: unhandled special operator ~:@M" (CAR EXP))
  184.      (THROW 'LISP->LISP-TR-LAMBDA ()))
  185.     ('ELSE
  186.      (TR-LISP->LISP-FUN EXP))))
  187.  
  188. (DEFUN TR-LISP->LISP-FUN (EXP)
  189.   (CONS (CAR EXP) (MAPTR-LISP->LISP (CDR EXP))))
  190.  
  191. (DEFUN MAPTR-LISP->LISP (L)
  192.   (MAPCAR #'TR-LISP->LISP L))
  193. (DEFUN-prop (declare TR-LISP->LISP) (FORM)
  194.   form)
  195.  
  196. (DEFUN-prop (LAMBDA TR-LISP->LISP) (FORM)
  197.   (LET (((() ARGLIST . BODY) FORM))
  198.     (MAPC #'TBIND  ARGLIST)
  199.     (SETQ BODY (MAPTR-LISP->LISP BODY))
  200.     `(function (LAMBDA ,(TUNBINDS ARGLIST) ,@BODY))))
  201.  
  202. (DEFUN-prop (PROG TR-LISP->LISP) (FORM)
  203.   (LET (((() ARGLIST . BODY) FORM))
  204.     (MAPC #'TBIND ARGLIST)
  205.     (SETQ BODY (MAPCAR #'(LAMBDA (X)
  206.                (IF (ATOM X) X
  207.                    (TR-LISP->LISP X)))
  208.                BODY))
  209.     `(PROG ,(TUNBINDS ARGLIST) ,@BODY)))
  210.  
  211. ;;(DEFUN RETLIST FEXPR (L)
  212. ;;  (CONS '(MLIST SIMP)
  213. ;;       (MAPCAR #'(LAMBDA (Z) (LIST '(MEQUAL SIMP) Z (MEVAL Z))) L)))
  214.  
  215. (DEFUN-prop (RETLIST TR-LISP->LISP) (FORM)
  216.   (PUSH-AUTOLOAD-DEF 'MARRAYREF '(RETLIST_TR))
  217.   `(RETLIST_TR ,@(MAPCAN #'(LAMBDA (Z)
  218.                  (LIST `',Z (TR-LISP->LISP Z)))
  219.              (CDR FORM))))
  220.  
  221. (DEFUN-prop (QUOTE TR-LISP->LISP) (FORM) FORM)
  222. (DEFPROP CATCH TR-LISP->LISP-FUN TR-LISP->LISP)
  223. (DEFPROP THROW TR-LISP->LISP-FUN TR-LISP->LISP)
  224. (DEFPROP RETURN TR-LISP->LISP-FUN TR-LISP->LISP)
  225. (DEFPROP FUNCTION TR-LISP->LISP-FUN TR-LISP->LISP)
  226.  
  227. (DEFUN-prop (SETQ TR-LISP->LISP) (FORM)
  228.   (DO ((L (CDR FORM) (CDDR L))
  229.        (N ()))
  230.       ((NULL L) (CONS 'SETQ (NREVERSE N)))
  231.     (PUSH (CAR L) N)
  232.     (PUSH (TR-LISP->LISP (CADR L)) N)))
  233.  
  234. (DEFUN-prop (MSETQ TR-LISP->LISP) (FORM)
  235.   (CDR (TRANSLATE `((MSETQ) ,@(CDR FORM)))))
  236.  
  237. (DEFUN-prop (COND TR-LISP->LISP) (FORM)
  238.   (CONS 'COND (MAPCAR #'MAPTR-LISP->LISP (CDR FORM))))
  239.  
  240. (DEFPROP NOT TR-LISP->LISP-FUN TR-LISP->LISP)
  241. (DEFPROP AND TR-LISP->LISP-FUN TR-LISP->LISP)
  242. (DEFPROP OR TR-LISP->LISP-FUN TR-LISP->LISP)
  243.  
  244. (DEFVAR UNBOUND-MEVAL-KLUDGE-FIX T)
  245.  
  246. (DEFUN-prop (MEVAL TR-LISP->LISP) (FORM)
  247.   (SETQ FORM (CADR FORM))
  248.   (COND ((AND (NOT (ATOM FORM))
  249.           (EQ (CAR FORM) 'QUOTE))
  250.      (CDR (TRANSLATE (CADR FORM))))
  251.     (UNBOUND-MEVAL-KLUDGE-FIX
  252.      ;; only case of unbound MEVAL is in output of DEFMATCH,
  253.      ;; and appears like a useless double-evaluation of arguments.
  254.      FORM)
  255.     ('ELSE
  256.      (TR-TELL "Punting: Unbound MEVAL found!")
  257.      (THROW 'LISP->LISP-TR-LAMBDA ()))))
  258.  
  259. (DEFUN-prop (IS TR-LISP->LISP) (FORM)
  260.   (SETQ FORM (CADR FORM))
  261.   (COND ((AND (NOT (ATOM FORM))
  262.           (EQ (CAR FORM) 'QUOTE))
  263.      (CDR (TRANSLATE `(($IS) ,(CADR FORM)))))
  264.     ('ELSE
  265.      (TR-TELL "Punting: Unbound IS found!")
  266.      (THROW 'LISP->LISP-TR-LAMBDA ()))))
  267.